home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / mac / tclMacResource.c < prev    next >
Encoding:
C/C++ Source or Header  |  1997-08-15  |  31.7 KB  |  1,242 lines  |  [TEXT/CWIE]
  1. /*
  2.  * tclMacResource.c --
  3.  *
  4.  *    This file contains several commands that manipulate or use
  5.  *    Macintosh resources.  Included are extensions to the "source"
  6.  *    command, the mac specific "beep" and "resource" commands, and
  7.  *    administration for open resource file references.
  8.  *
  9.  * Copyright (c) 1996-1997 Sun Microsystems, Inc.
  10.  *
  11.  * See the file "license.terms" for information on usage and redistribution
  12.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13.  *
  14.  * SCCS: @(#) tclMacResource.c 1.23 97/06/13 18:58:59
  15.  */
  16.  
  17. #include <FSpCompat.h>
  18. #include <Resources.h>
  19. #include <Sound.h>
  20. #include <Strings.h>
  21.  
  22. #include "tcl.h"
  23. #include "tclInt.h"
  24. #include "tclMac.h"
  25. #include "tclMacInt.h"
  26. #include "tclMacPort.h"
  27.  
  28. /*
  29.  * Hash table to track open resource files.
  30.  */
  31. static Tcl_HashTable nameTable;        /* Id to process number mapping. */
  32. static Tcl_HashTable resourceTable;    /* Process number to id mapping. */
  33. static int newId = 0;            /* Id source. */
  34. static int initialized = 0;        /* 0 means static structures haven't 
  35.                      * been initialized yet. */
  36. static int osTypeInit = 0;        /* 0 means Tcl object of osType hasn't 
  37.                      * been initialized yet. */
  38. /*
  39.  * Prototypes for procedures defined later in this file:
  40.  */
  41.  
  42. static void        DupOSTypeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
  43.                 Tcl_Obj *copyPtr));
  44. static void        ResourceInit _ANSI_ARGS_((void));
  45. static int        SetOSTypeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
  46.                 Tcl_Obj *objPtr));
  47. static void        UpdateStringOfOSType _ANSI_ARGS_((Tcl_Obj *objPtr));
  48.  
  49. /*
  50.  * The structures below defines the Tcl object type defined in this file by
  51.  * means of procedures that can be invoked by generic object code.
  52.  */
  53.  
  54. static Tcl_ObjType osType = {
  55.     "ostype",                /* name */
  56.     (Tcl_FreeInternalRepProc *) NULL,   /* freeIntRepProc */
  57.     DupOSTypeInternalRep,            /* dupIntRepProc */
  58.     UpdateStringOfOSType,        /* updateStringProc */
  59.     SetOSTypeFromAny            /* setFromAnyProc */
  60. };
  61.  
  62. /*
  63.  *----------------------------------------------------------------------
  64.  *
  65.  * Tcl_ResourceObjCmd --
  66.  *
  67.  *    This procedure is invoked to process the "resource" Tcl command.
  68.  *    See the user documentation for details on what it does.
  69.  *
  70.  * Results:
  71.  *    A standard Tcl result.
  72.  *
  73.  * Side effects:
  74.  *    See the user documentation.
  75.  *
  76.  *----------------------------------------------------------------------
  77.  */
  78.  
  79. int
  80. Tcl_ResourceObjCmd(
  81.     ClientData clientData,        /* Not used. */
  82.     Tcl_Interp *interp,            /* Current interpreter. */
  83.     int objc,                /* Number of arguments. */
  84.     Tcl_Obj *CONST objv[])        /* Argument values. */
  85. {
  86.     Tcl_Obj *resultPtr, *objPtr;
  87.     int index, result;
  88.     long fileRef, rsrcId;
  89.     FSSpec fileSpec;
  90.     Tcl_DString buffer;
  91.     char *nativeName;
  92.     char *stringPtr;
  93.     Tcl_HashEntry *resourceHashPtr;
  94.     Tcl_HashEntry *nameHashPtr;
  95.     Handle resource;
  96.     OSErr err;
  97.     int count, i, limitSearch = false, length;
  98.     short id, saveRef;
  99.     Str255 theName;
  100.     OSType rezType;
  101.     int new, gotInt,releaseIt = 0;
  102.     char *resourceId = NULL;    
  103.     long size;
  104.     char macPermision;
  105.     int mode;
  106.  
  107.     static char *writeSwitches[] = {"-id", "-name", "-file", (char *) NULL};
  108.     static char *switches[] =
  109.         {"close", "list", "open", "read", "types", "write", (char *) NULL};
  110.  
  111.     resultPtr = Tcl_GetObjResult(interp);
  112.     if (objc < 2) {
  113.     Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
  114.     return TCL_ERROR;
  115.     }
  116.  
  117.     if (Tcl_GetIndexFromObj(interp, objv[1], switches, "option", 0, &index)
  118.         != TCL_OK) {
  119.     return TCL_ERROR;
  120.     }
  121.     if (!initialized) {
  122.     ResourceInit();
  123.     }
  124.     result = TCL_OK;
  125.  
  126.     switch (index) {
  127.     case 0:            /* close */
  128.         if (objc != 3) {
  129.         Tcl_WrongNumArgs(interp, 2, objv, "resourceRef");
  130.         return TCL_ERROR;
  131.         }
  132.         stringPtr = Tcl_GetStringFromObj(objv[2], &length);
  133.         nameHashPtr = Tcl_FindHashEntry(&nameTable, stringPtr);
  134.         if (nameHashPtr == NULL) {
  135.         Tcl_AppendStringsToObj(resultPtr,
  136.             "invalid resource file reference \"",
  137.             stringPtr, "\"", (char *) NULL);
  138.         return TCL_ERROR;
  139.         }
  140.         fileRef = (long) Tcl_GetHashValue(nameHashPtr);
  141.         if (fileRef == 0) {
  142.         Tcl_AppendStringsToObj(resultPtr,
  143.             "can't close system resource", (char *) NULL);
  144.         return TCL_ERROR;
  145.         }
  146.         Tcl_DeleteHashEntry(nameHashPtr);
  147.         resourceHashPtr = Tcl_FindHashEntry(&resourceTable, (char *) fileRef);
  148.         if (resourceHashPtr == NULL) {
  149.         panic("how did this happen");
  150.         }
  151.         ckfree(Tcl_GetHashValue(resourceHashPtr));
  152.         Tcl_DeleteHashEntry(resourceHashPtr);
  153.  
  154.         CloseResFile((short) fileRef);
  155.         return TCL_OK;
  156.     case 1:            /* list */
  157.         if (!((objc == 3) || (objc == 4))) {
  158.         Tcl_WrongNumArgs(interp, 2, objv, "resourceType ?resourceRef?");
  159.         return TCL_ERROR;
  160.         }
  161.         if (Tcl_GetOSTypeFromObj(interp, objv[2], &rezType) != TCL_OK) {
  162.         return TCL_ERROR;
  163.         }
  164.  
  165.         if (objc == 4) {
  166.         stringPtr = Tcl_GetStringFromObj(objv[3], &length);
  167.         nameHashPtr = Tcl_FindHashEntry(&nameTable, stringPtr);
  168.         if (nameHashPtr == NULL) {
  169.             Tcl_AppendStringsToObj(resultPtr,
  170.             "invalid resource file reference \"",
  171.             stringPtr, "\"", (char *) NULL);
  172.             return TCL_ERROR;
  173.         }
  174.         fileRef = (long) Tcl_GetHashValue(nameHashPtr);
  175.         saveRef = CurResFile();
  176.         UseResFile((short) fileRef);
  177.         limitSearch = true;
  178.         }
  179.  
  180.         Tcl_ResetResult(interp);
  181.         if (limitSearch) {
  182.         count = Count1Resources(rezType);
  183.         } else {
  184.         count = CountResources(rezType);
  185.         }
  186.         SetResLoad(false);
  187.         for (i = 1; i <= count; i++) {
  188.         if (limitSearch) {
  189.             resource = Get1IndResource(rezType, i);
  190.         } else {
  191.             resource = GetIndResource(rezType, i);
  192.         }
  193.         if (resource != NULL) {
  194.             GetResInfo(resource, &id, (ResType *) &rezType, theName);
  195.             if (theName[0] != 0) {
  196.             objPtr = Tcl_NewStringObj((char *) theName + 1, theName[0]);
  197.             } else {
  198.             objPtr = Tcl_NewIntObj(id);
  199.             }
  200.             ReleaseResource(resource);
  201.             result = Tcl_ListObjAppendElement(interp, resultPtr, objPtr);
  202.             if (result != TCL_OK) {
  203.             Tcl_DecrRefCount(objPtr);
  204.             break;
  205.             }
  206.         }
  207.         }
  208.         SetResLoad(true);
  209.     
  210.         if (limitSearch) {
  211.         UseResFile(saveRef);
  212.         }
  213.     
  214.         return TCL_OK;
  215.     case 2:            /* open */
  216.         if (!((objc == 3) || (objc == 4))) {
  217.         Tcl_WrongNumArgs(interp, 2, objv, "fileName ?permissions?");
  218.         return TCL_ERROR;
  219.         }
  220.         stringPtr = Tcl_GetStringFromObj(objv[2], &length);
  221.         nativeName = Tcl_TranslateFileName(interp, stringPtr, &buffer);
  222.         if (nativeName == NULL) {
  223.         return TCL_ERROR;
  224.         }
  225.         err = FSpLocationFromPath(strlen(nativeName), nativeName,
  226.             &fileSpec) ;
  227.         Tcl_DStringFree(&buffer);
  228.         if (!((err == noErr) || (err == fnfErr))) {
  229.         Tcl_AppendStringsToObj(resultPtr,
  230.             "invalid path", (char *) NULL);
  231.         return TCL_ERROR;
  232.         }
  233.  
  234.         /*
  235.          * Get permissions for the file.  We really only understand
  236.          * read-only and shared-read-write.  If no permissions are given we
  237.          * default to read only.
  238.          */
  239.         
  240.         if (objc == 4) {
  241.         stringPtr = Tcl_GetStringFromObj(objv[3], &length);
  242.         mode = TclGetOpenMode(interp, stringPtr, &index);
  243.         if (mode == -1) {
  244.             /* TODO: TclGetOpenMode doesn't work with Obj commands. */
  245.             return TCL_ERROR;
  246.         }
  247.         switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
  248.             case O_RDONLY:
  249.             macPermision = fsRdPerm;
  250.             break;
  251.             case O_WRONLY:
  252.             case O_RDWR:
  253.             macPermision = fsRdWrShPerm;
  254.             break;
  255.             default:
  256.             panic("Tcl_ResourceObjCmd: invalid mode value");
  257.             break;
  258.         }
  259.         } else {
  260.         macPermision = fsRdPerm;
  261.         }
  262.         
  263.         fileRef = (long) FSpOpenResFileCompat(&fileSpec, macPermision);
  264.         if (fileRef == -1) {
  265.             err = ResError();
  266.         if (((err == fnfErr) || (err == eofErr)) &&
  267.             (macPermision == fsRdWrShPerm)) {
  268.             /*
  269.              * No resource fork existed for this file.  Since we are
  270.              * opening it for writing we will create the resource fork
  271.              * now.
  272.              */
  273.             HCreateResFile(fileSpec.vRefNum, fileSpec.parID,
  274.                 fileSpec.name);
  275.             fileRef = (long) FSpOpenResFileCompat(&fileSpec,
  276.                 macPermision);
  277.             if (fileRef == -1) {
  278.             goto openError;
  279.             }
  280.         } else if (err == fnfErr) {
  281.             Tcl_AppendStringsToObj(resultPtr,
  282.             "file does not exist", (char *) NULL);
  283.             return TCL_ERROR;
  284.         } else if (err == eofErr) {
  285.             Tcl_AppendStringsToObj(resultPtr,
  286.             "file does not contain resource fork", (char *) NULL);
  287.             return TCL_ERROR;
  288.         } else {
  289.             openError:
  290.             Tcl_AppendStringsToObj(resultPtr,
  291.             "error opening resource file", (char *) NULL);
  292.             return TCL_ERROR;
  293.         }
  294.         }
  295.         
  296.         resourceHashPtr = Tcl_CreateHashEntry(&resourceTable,
  297.             (char *) fileRef, &new);
  298.         if (!new) {
  299.         resourceId = (char *) Tcl_GetHashValue(resourceHashPtr);
  300.         Tcl_SetStringObj(resultPtr, resourceId, -1);
  301.         return TCL_OK;
  302.         }
  303.           
  304.         resourceId = (char *) ckalloc(15);
  305.         sprintf(resourceId, "resource%d", newId);
  306.         Tcl_SetHashValue(resourceHashPtr, resourceId);
  307.         newId++;
  308.  
  309.         nameHashPtr = Tcl_CreateHashEntry(&nameTable, resourceId, &new);
  310.         if (!new) {
  311.         panic("resource id has repeated itself");
  312.         }
  313.         Tcl_SetHashValue(nameHashPtr, fileRef);
  314.         
  315.         Tcl_SetStringObj(resultPtr, resourceId, -1);
  316.         return TCL_OK;
  317.     case 3:            /* read */
  318.         if (!((objc == 4) || (objc == 5))) {
  319.         Tcl_WrongNumArgs(interp, 2, objv,
  320.             "resourceType resourceId ?resourceRef?");
  321.         return TCL_ERROR;
  322.         }
  323.  
  324.         if (Tcl_GetOSTypeFromObj(interp, objv[2], &rezType) != TCL_OK) {
  325.         return TCL_ERROR;
  326.         }
  327.         
  328.         if (Tcl_GetLongFromObj((Tcl_Interp *) NULL, objv[3], &rsrcId)
  329.             != TCL_OK) {
  330.         resourceId = Tcl_GetStringFromObj(objv[3], &length);
  331.             }
  332.  
  333.         if (objc == 5) {
  334.         stringPtr = Tcl_GetStringFromObj(objv[4], &length);
  335.         } else {
  336.         stringPtr = NULL;
  337.         }
  338.     
  339.         resource = Tcl_MacFindResource(interp, rezType, resourceId,
  340.         rsrcId, stringPtr, &releaseIt);
  341.                 
  342.         if (resource != NULL) {
  343.         size = GetResourceSizeOnDisk(resource);
  344.         Tcl_SetStringObj(resultPtr, *resource, size);
  345.  
  346.         /*
  347.          * Don't release the resource unless WE loaded it...
  348.          */
  349.          
  350.         if (releaseIt) {
  351.             ReleaseResource(resource);
  352.         }
  353.         return TCL_OK;
  354.         } else {
  355.         Tcl_AppendStringsToObj(resultPtr, "could not load resource",
  356.             (char *) NULL);
  357.         return TCL_ERROR;
  358.         }
  359.     case 4:            /* types */
  360.         if (!((objc == 2) || (objc == 3))) {
  361.         Tcl_WrongNumArgs(interp, 2, objv, "?resourceRef?");
  362.         return TCL_ERROR;
  363.         }
  364.  
  365.         if (objc == 3) {
  366.         stringPtr = Tcl_GetStringFromObj(objv[2], &length);
  367.         nameHashPtr = Tcl_FindHashEntry(&nameTable, stringPtr);
  368.         if (nameHashPtr == NULL) {
  369.             Tcl_AppendStringsToObj(resultPtr,
  370.             "invalid resource file reference \"",
  371.             stringPtr, "\"", (char *) NULL);
  372.             return TCL_ERROR;
  373.         }
  374.         fileRef = (long) Tcl_GetHashValue(nameHashPtr);
  375.         saveRef = CurResFile();
  376.         UseResFile((short) fileRef);
  377.         limitSearch = true;
  378.         }
  379.  
  380.         if (limitSearch) {
  381.         count = Count1Types();
  382.         } else {
  383.         count = CountTypes();
  384.         }
  385.         for (i = 1; i <= count; i++) {
  386.         if (limitSearch) {
  387.             Get1IndType((ResType *) &rezType, i);
  388.         } else {
  389.             GetIndType((ResType *) &rezType, i);
  390.         }
  391.         objPtr = Tcl_NewOSTypeObj(rezType);
  392.         result = Tcl_ListObjAppendElement(interp, resultPtr, objPtr);
  393.         if (result != TCL_OK) {
  394.             Tcl_DecrRefCount(objPtr);
  395.             break;
  396.         }
  397.         }
  398.         
  399.         if (limitSearch) {
  400.         UseResFile(saveRef);
  401.         }
  402.         
  403.         return result;
  404.     case 5:            /* write */
  405.         if (!((objc >= 4) && (objc <= 10) && ((objc % 2) == 0))) {
  406.         Tcl_WrongNumArgs(interp, 2, objv, 
  407.             "?-id resourceId? ?-name resourceName? ?-file resourceRef? resourceType data");
  408.         return TCL_ERROR;
  409.         }
  410.         
  411.         i = 2;
  412.         fileRef = -1;
  413.         gotInt = false;
  414.         resourceId = NULL;
  415.         limitSearch = false;
  416.  
  417.         while (i < (objc - 2)) {
  418.         if (Tcl_GetIndexFromObj(interp, objv[i], writeSwitches,
  419.             "option", 0, &index) != TCL_OK) {
  420.             return TCL_ERROR;
  421.         }
  422.  
  423.         switch (index) {
  424.             case 0:            /* -id */
  425.             if (Tcl_GetLongFromObj(interp, objv[i+1], &rsrcId)
  426.                 != TCL_OK) {
  427.                 return TCL_ERROR;
  428.             }
  429.             gotInt = true;
  430.             break;
  431.             case 1:            /* -name */
  432.             resourceId = Tcl_GetStringFromObj(objv[i+1], &length);
  433.             strcpy((char *) theName, resourceId);
  434.             resourceId = (char *) theName;
  435.             c2pstr(resourceId);
  436.             break;
  437.             case 2:            /* -file */
  438.             stringPtr = Tcl_GetStringFromObj(objv[i+1], &length);
  439.             nameHashPtr = Tcl_FindHashEntry(&nameTable, stringPtr);
  440.             if (nameHashPtr == NULL) {
  441.                 Tcl_AppendStringsToObj(resultPtr,
  442.                     "invalid resource file reference \"",
  443.                     stringPtr, "\"", (char *) NULL);
  444.                 return TCL_ERROR;
  445.             }
  446.             fileRef = (long) Tcl_GetHashValue(nameHashPtr);
  447.             limitSearch = true;
  448.             break;
  449.         }
  450.         i += 2;
  451.         }
  452.         if (Tcl_GetOSTypeFromObj(interp, objv[i], &rezType) != TCL_OK) {
  453.         return TCL_ERROR;
  454.         }
  455.         stringPtr = Tcl_GetStringFromObj(objv[i+1], &length);
  456.  
  457.         if (gotInt == false) {
  458.         rsrcId = UniqueID(rezType);
  459.         }
  460.         if (resourceId == NULL) {
  461.         resourceId = (char *) "\p";
  462.         }
  463.         if (limitSearch) {
  464.         saveRef = CurResFile();
  465.         UseResFile((short) fileRef);
  466.         }
  467.         
  468.         resource = NewHandle(length);
  469.         HLock(resource);
  470.         memcpy(*resource, stringPtr, length);
  471.         HUnlock(resource);
  472.         AddResource(resource, rezType, (short) rsrcId,
  473.         (StringPtr) resourceId);
  474.         err = ResError();
  475.         if (err != noErr) {
  476.         SysBeep(1);
  477.         }
  478.         WriteResource(resource);
  479.         err = ResError();
  480.         if (err != noErr) {
  481.         SysBeep(1);
  482.         }
  483.         ReleaseResource(resource);
  484.         err = ResError();
  485.         if (err != noErr) {
  486.         SysBeep(1);
  487.         }
  488.         
  489.         if (limitSearch) {
  490.         UseResFile(saveRef);
  491.         }
  492.  
  493.         return result;
  494.     default:
  495.         return TCL_ERROR;    /* Should never be reached. */
  496.     }
  497. }
  498.  
  499. /*
  500.  *----------------------------------------------------------------------
  501.  *
  502.  * Tcl_MacSourceObjCmd --
  503.  *
  504.  *    This procedure is invoked to process the "source" Tcl command.
  505.  *    See the user documentation for details on what it does.  In 
  506.  *    addition, it supports sourceing from the resource fork of
  507.  *    type 'TEXT'.
  508.  *
  509.  * Results:
  510.  *    A standard Tcl result.
  511.  *
  512.  * Side effects:
  513.  *    See the user documentation.
  514.  *
  515.  *----------------------------------------------------------------------
  516.  */
  517.  
  518. int
  519. Tcl_MacSourceObjCmd(
  520.     ClientData dummy,            /* Not used. */
  521.     Tcl_Interp *interp,            /* Current interpreter. */
  522.     int objc,                /* Number of arguments. */
  523.     Tcl_Obj *CONST objv[])        /* Argument objects. */
  524. {
  525.     char *errNum = "wrong # args: ";
  526.     char *errBad = "bad argument: ";
  527.     char *errStr;
  528.     char *fileName = NULL, *rsrcName = NULL;
  529.     long rsrcID = -1;
  530.     char *string;
  531.     int length;
  532.  
  533.     if (objc < 2 || objc > 4)  {
  534.         errStr = errNum;
  535.         goto sourceFmtErr;
  536.     }
  537.     
  538.     if (objc == 2)  {
  539.     string = TclGetStringFromObj(objv[1], &length);
  540.     return Tcl_EvalFile(interp, string);
  541.     }
  542.     
  543.     /*
  544.      * The following code supports a few older forms of this command
  545.      * for backward compatability.
  546.      */
  547.     string = TclGetStringFromObj(objv[1], &length);
  548.     if (!strcmp(string, "-rsrc") || !strcmp(string, "-rsrcname")) {
  549.     rsrcName = TclGetStringFromObj(objv[2], &length);
  550.     } else if (!strcmp(string, "-rsrcid")) {
  551.     if (Tcl_GetLongFromObj(interp, objv[2], &rsrcID) != TCL_OK) {
  552.         return TCL_ERROR;
  553.     }
  554.     } else {
  555.         errStr = errBad;
  556.         goto sourceFmtErr;
  557.     }
  558.     
  559.     if (objc == 4) {
  560.     fileName = TclGetStringFromObj(objv[3], &length);
  561.     }
  562.     return Tcl_MacEvalResource(interp, rsrcName, rsrcID, fileName);
  563.     
  564.     sourceFmtErr:
  565.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), errStr, "should be \"",
  566.         Tcl_GetStringFromObj(objv[0], (int *) NULL),
  567.         " fileName\" or \"",
  568.         Tcl_GetStringFromObj(objv[0], (int *) NULL),
  569.         " -rsrc name ?fileName?\" or \"", 
  570.         Tcl_GetStringFromObj(objv[0], (int *) NULL),
  571.         " -rsrcid id ?fileName?\"", (char *) NULL);
  572.     return TCL_ERROR;
  573. }
  574.  
  575. /*
  576.  *----------------------------------------------------------------------
  577.  *
  578.  * Tcl_BeepObjCmd --
  579.  *
  580.  *    This procedure makes the beep sound.
  581.  *
  582.  * Results:
  583.  *    A standard Tcl result.
  584.  *
  585.  * Side effects:
  586.  *    Makes a beep.
  587.  *
  588.  *----------------------------------------------------------------------
  589.  */
  590.  
  591. int
  592. Tcl_BeepObjCmd(
  593.     ClientData dummy,            /* Not used. */
  594.     Tcl_Interp *interp,            /* Current interpreter. */
  595.     int objc,                /* Number of arguments. */
  596.     Tcl_Obj *CONST objv[])        /* Argument values. */
  597. {
  598.     Tcl_Obj *resultPtr, *objPtr;
  599.     Handle sound;
  600.     Str255 sndName;
  601.     int volume = -1, length;
  602.     char * sndArg = NULL;
  603.     long curVolume;
  604.  
  605.     resultPtr = Tcl_GetObjResult(interp);
  606.     if (objc == 1) {
  607.     SysBeep(1);
  608.     return TCL_OK;
  609.     } else if (objc == 2) {
  610.     if (!strcmp(Tcl_GetStringFromObj(objv[1], &length), "-list")) {
  611.         int count, i;
  612.         short id;
  613.         Str255 theName;
  614.         ResType rezType;
  615.             
  616.         count = CountResources('snd ');
  617.         for (i = 1; i <= count; i++) {
  618.         sound = GetIndResource('snd ', i);
  619.         if (sound != NULL) {
  620.             GetResInfo(sound, &id, &rezType, theName);
  621.             if (theName[0] == 0) {
  622.             continue;
  623.             }
  624.             objPtr = Tcl_NewStringObj((char *) theName + 1,
  625.                 theName[0]);
  626.             Tcl_ListObjAppendElement(interp, resultPtr, objPtr);
  627.         }
  628.         }
  629.         return TCL_OK;
  630.     } else {
  631.         sndArg = Tcl_GetStringFromObj(objv[1], &length);
  632.     }
  633.     } else if (objc == 3) {
  634.     if (!strcmp(Tcl_GetStringFromObj(objv[1], &length), "-volume")) {
  635.         Tcl_GetIntFromObj(interp, objv[2], &volume);
  636.     } else {
  637.         goto beepUsage;
  638.     }
  639.     } else if (objc == 4) {
  640.     if (!strcmp(Tcl_GetStringFromObj(objv[1], &length), "-volume")) {
  641.         Tcl_GetIntFromObj(interp, objv[2], &volume);
  642.         sndArg = Tcl_GetStringFromObj(objv[3], &length);
  643.     } else {
  644.         goto beepUsage;
  645.     }
  646.     } else {
  647.     goto beepUsage;
  648.     }
  649.     
  650.     /*
  651.      * Set Volume
  652.      */
  653.     if (volume >= 0) {
  654.     GetSysBeepVolume(&curVolume);
  655.     SetSysBeepVolume((short) volume);
  656.     }
  657.     
  658.     /*
  659.      * Play the sound
  660.      */
  661.     if (sndArg == NULL) {
  662.     SysBeep(1);
  663.     } else {
  664.     strcpy((char *) sndName + 1, sndArg);
  665.     sndName[0] = length;
  666.     sound = GetNamedResource('snd ', sndName);
  667.     if (sound != NULL) {
  668.         SndPlay(NULL, (SndListHandle) sound, false);
  669.         return TCL_OK;
  670.     } else {
  671.         if (volume >= 0) {
  672.         SetSysBeepVolume(curVolume);
  673.         }
  674.         Tcl_AppendStringsToObj(resultPtr, " \"", sndArg, 
  675.             "\" is not a valid sound.  (Try ",
  676.             Tcl_GetStringFromObj(objv[0], (int *) NULL),
  677.             " -list)", NULL);
  678.         return TCL_ERROR;
  679.     }
  680.     }
  681.  
  682.     /*
  683.      * Reset Volume
  684.      */
  685.     if (volume >= 0) {
  686.     SetSysBeepVolume(curVolume);
  687.     }
  688.     return TCL_OK;
  689.  
  690.     beepUsage:
  691.     Tcl_WrongNumArgs(interp, 1, objv, "[-volume num] [-list | sndName]?");
  692.     return TCL_ERROR;
  693. }
  694.  
  695. /*
  696.  *-----------------------------------------------------------------------------
  697.  *
  698.  * Tcl_MacEvalResource --
  699.  *
  700.  *    Used to extend the source command.  Sources Tcl code from a Text
  701.  *    resource.  Currently only sources the resouce by name file ID may be
  702.  *    supported at a later date.
  703.  *
  704.  * Side Effects:
  705.  *    Depends on the Tcl code in the resource.
  706.  *
  707.  * Results:
  708.  *      Returns a Tcl result.
  709.  *
  710.  *-----------------------------------------------------------------------------
  711.  */
  712.  
  713. int
  714. Tcl_MacEvalResource(
  715.     Tcl_Interp *interp,        /* Interpreter in which to process file. */
  716.     char *resourceName,        /* Name of TEXT resource to source,
  717.                    NULL if number should be used. */
  718.     int resourceNumber,        /* Resource id of source. */
  719.     char *fileName)        /* Name of file to process.
  720.                    NULL if application resource. */
  721. {
  722.     Handle sourceText;
  723.     Str255 rezName;
  724.     char msg[200];
  725.     int result;
  726.     short saveRef, fileRef = -1;
  727.     char idStr[64];
  728.     FSSpec fileSpec;
  729.     Tcl_DString buffer;
  730.     char *nativeName;
  731.  
  732.     saveRef = CurResFile();
  733.     
  734.     if (fileName != NULL) {
  735.     OSErr err;
  736.     
  737.     nativeName = Tcl_TranslateFileName(interp, fileName, &buffer);
  738.     if (nativeName == NULL) {
  739.         return TCL_ERROR;
  740.     }
  741.     err = FSpLocationFromPath(strlen(nativeName), nativeName, &fileSpec);
  742.     Tcl_DStringFree(&buffer);
  743.     if (err != noErr) {
  744.         Tcl_AppendResult(interp, "Error finding the file: \"", 
  745.         fileName, "\".", NULL);
  746.         return TCL_ERROR;
  747.     }
  748.         
  749.     fileRef = FSpOpenResFileCompat(&fileSpec, fsRdPerm);
  750.     if (fileRef == -1) {
  751.         Tcl_AppendResult(interp, "Error reading the file: \"", 
  752.         fileName, "\".", NULL);
  753.         return TCL_ERROR;
  754.     }
  755.         
  756.     UseResFile(fileRef);
  757.     } else {
  758.     /*
  759.      * The default behavior will search through all open resource files.
  760.      * This may not be the behavior you desire.  If you want the behavior
  761.      * of this call to *only* search the application resource fork, you
  762.      * must call UseResFile at this point to set it to the application
  763.      * file.  This means you must have already obtained the application's 
  764.      * fileRef when the application started up.
  765.      */
  766.     }
  767.     
  768.     /*
  769.      * Load the resource by name or ID
  770.      */
  771.     if (resourceName != NULL) {
  772.     strcpy((char *) rezName + 1, resourceName);
  773.     rezName[0] = strlen(resourceName);
  774.     sourceText = GetNamedResource('TEXT', rezName);
  775.     } else {
  776.     sourceText = GetResource('TEXT', (short) resourceNumber);
  777.     }
  778.     
  779.     if (sourceText == NULL) {
  780.     result = TCL_ERROR;
  781.     } else {
  782.     char *sourceStr = NULL;
  783.     
  784.     sourceStr = Tcl_MacConvertTextResource(sourceText);
  785.     ReleaseResource(sourceText);
  786.         
  787.     /*
  788.      * We now evaluate the Tcl source
  789.      */
  790.     result = Tcl_Eval(interp, sourceStr);
  791.     ckfree(sourceStr);
  792.     if (result == TCL_RETURN) {
  793.         result = TCL_OK;
  794.     } else if (result == TCL_ERROR) {
  795.         sprintf(msg, "\n    (rsrc \"%.150s\" line %d)", resourceName,
  796.             interp->errorLine);
  797.         Tcl_AddErrorInfo(interp, msg);
  798.     }
  799.                 
  800.     goto rezEvalCleanUp;
  801.     }
  802.     
  803.     rezEvalError:
  804.     sprintf(idStr, "ID=%d", resourceNumber);
  805.     Tcl_AppendResult(interp, "The resource \"",
  806.         (resourceName != NULL ? resourceName : idStr),
  807.         "\" could not be loaded from ",
  808.         (fileName != NULL ? fileName : "application"),
  809.         ".", NULL);
  810.  
  811.     rezEvalCleanUp:
  812.     if (fileRef != -1) {
  813.     CloseResFile(fileRef);
  814.     }
  815.  
  816.     UseResFile(saveRef);
  817.     
  818.     return result;
  819. }
  820.  
  821. /*
  822.  *-----------------------------------------------------------------------------
  823.  *
  824.  * Tcl_MacConvertTextResource --
  825.  *
  826.  *    Converts a TEXT resource into a Tcl suitable string.
  827.  *
  828.  * Side Effects:
  829.  *    Mallocs the returned memory, converts '\r' to '\n', and appends a NULL.
  830.  *
  831.  * Results:
  832.  *      A new malloced string.
  833.  *
  834.  *-----------------------------------------------------------------------------
  835.  */
  836.  
  837. char *
  838. Tcl_MacConvertTextResource(
  839.     Handle resource)        /* Handle to TEXT resource. */
  840. {
  841.     int i, size;
  842.     char *resultStr;
  843.  
  844.     size = SizeResource(resource);
  845.     
  846.     resultStr = ckalloc(size + 1);
  847.     
  848.     for (i=0; i<size; i++) {
  849.     if ((*resource)[i] == '\r') {
  850.         resultStr[i] = '\n';
  851.     } else {
  852.         resultStr[i] = (*resource)[i];
  853.     }
  854.     }
  855.     
  856.     resultStr[size] = '\0';
  857.  
  858.     return resultStr;
  859. }
  860.  
  861. /*
  862.  *-----------------------------------------------------------------------------
  863.  *
  864.  * Tcl_MacFindResource --
  865.  *
  866.  *    Higher level interface for loading resources.
  867.  *
  868.  * Side Effects:
  869.  *    Attempts to load a resource.
  870.  *
  871.  * Results:
  872.  *      A handle on success.
  873.  *
  874.  *-----------------------------------------------------------------------------
  875.  */
  876.  
  877. Handle
  878. Tcl_MacFindResource(
  879.     Tcl_Interp *interp,        /* Interpreter in which to process file. */
  880.     long resourceType,        /* Type of resource to load. */
  881.     char *resourceName,        /* Name of resource to source,
  882.                  * NULL if number should be used. */
  883.     int resourceNumber,        /* Resource id of source. */
  884.     char *resFileRef,        /* Registered resource file reference,
  885.                  * NULL if searching all open resource files. */
  886.     int *releaseIt)            /* Should we release this resource when done. */
  887. {
  888.     Tcl_HashEntry *nameHashPtr;
  889.     long fileRef;
  890.     int limitSearch = false;
  891.     short saveRef;
  892.     Handle resource;
  893.  
  894.     if (resFileRef != NULL) {
  895.     nameHashPtr = Tcl_FindHashEntry(&nameTable, resFileRef);
  896.     if (nameHashPtr == NULL) {
  897.         Tcl_AppendResult(interp, "invalid resource file reference \"",
  898.                  resFileRef, "\"", (char *) NULL);
  899.         return NULL;
  900.     }
  901.     fileRef = (long) Tcl_GetHashValue(nameHashPtr);
  902.     saveRef = CurResFile();
  903.     UseResFile((short) fileRef);
  904.     limitSearch = true;
  905.     }
  906.  
  907.     /* 
  908.      * Some system resources (for example system resources) should not 
  909.      * be released.  So we set autoload to false, and try to get the resource.
  910.      * If the Master Pointer of the returned handle is null, then resource was 
  911.      * not in memory, and it is safe to release it.  Otherwise, it is not.
  912.      */
  913.     
  914.     SetResLoad(false);
  915.      
  916.     if (resourceName == NULL) {
  917.     if (limitSearch) {
  918.         resource = Get1Resource(resourceType, resourceNumber);
  919.     } else {
  920.         resource = GetResource(resourceType, resourceNumber);
  921.     }
  922.     } else {
  923.     c2pstr(resourceName);
  924.     if (limitSearch) {
  925.         resource = Get1NamedResource(resourceType, (StringPtr) resourceName);
  926.     } else {
  927.         resource = GetNamedResource(resourceType, (StringPtr) resourceName);
  928.     }
  929.     p2cstr((StringPtr) resourceName);
  930.     }
  931.     
  932.     if (*resource == NULL) {
  933.         *releaseIt = 1;
  934.         LoadResource(resource);
  935.     } else {
  936.         *releaseIt = 0;
  937.     }
  938.     
  939.     SetResLoad(true);
  940.         
  941.  
  942.     if (limitSearch) {
  943.     UseResFile(saveRef);
  944.     }
  945.  
  946.     return resource;
  947. }
  948.  
  949. /*
  950.  *----------------------------------------------------------------------
  951.  *
  952.  * ResourceInit --
  953.  *
  954.  *    Initialize the structures used for resource management.
  955.  *
  956.  * Results:
  957.  *    None.
  958.  *
  959.  * Side effects:
  960.  *    Read the code.
  961.  *
  962.  *----------------------------------------------------------------------
  963.  */
  964.  
  965. static void
  966. ResourceInit()
  967. {
  968.     Tcl_HashEntry *resourceHashPtr;
  969.     Tcl_HashEntry *nameHashPtr;
  970.     long fileRef;
  971.     char * resourceId;
  972.     int new;
  973.  
  974.     initialized = 1;
  975.     Tcl_InitHashTable(&nameTable, TCL_STRING_KEYS);
  976.     Tcl_InitHashTable(&resourceTable, TCL_ONE_WORD_KEYS);
  977.  
  978.     /*
  979.      * Place the application resource file into our cache.
  980.      */
  981.     fileRef = CurResFile();
  982.     resourceHashPtr = Tcl_CreateHashEntry(&resourceTable, (char *) fileRef,
  983.         &new);
  984.     resourceId = (char *) ckalloc(strlen("application") + 1);
  985.     sprintf(resourceId, "application");
  986.     Tcl_SetHashValue(resourceHashPtr, resourceId);
  987.  
  988.     nameHashPtr = Tcl_CreateHashEntry(&nameTable, resourceId, &new);
  989.     Tcl_SetHashValue(nameHashPtr, fileRef);
  990.  
  991.     /*
  992.      * Place the system resource file into our cache.
  993.      */
  994.     fileRef = 0;
  995.     resourceHashPtr = Tcl_CreateHashEntry(&resourceTable, (char *) fileRef,
  996.         &new);
  997.     resourceId = (char *) ckalloc(strlen("system") + 1);
  998.     sprintf(resourceId, "system");
  999.     Tcl_SetHashValue(resourceHashPtr, resourceId);
  1000.  
  1001.     nameHashPtr = Tcl_CreateHashEntry(&nameTable, resourceId, &new);
  1002.     Tcl_SetHashValue(nameHashPtr, fileRef);
  1003. }
  1004. /***/
  1005.  
  1006. /*Tcl_RegisterObjType(typePtr) */
  1007.  
  1008. /*
  1009.  *----------------------------------------------------------------------
  1010.  *
  1011.  * Tcl_NewOSTypeObj --
  1012.  *
  1013.  *    This procedure is used to create a new resource name type object.
  1014.  *
  1015.  * Results:
  1016.  *    The newly created object is returned. This object will have a NULL
  1017.  *    string representation. The returned object has ref count 0.
  1018.  *
  1019.  * Side effects:
  1020.  *    None.
  1021.  *
  1022.  *----------------------------------------------------------------------
  1023.  */
  1024.  
  1025. Tcl_Obj *
  1026. Tcl_NewOSTypeObj(
  1027.     OSType newOSType)        /* Int used to initialize the new object. */
  1028. {
  1029.     register Tcl_Obj *objPtr;
  1030.  
  1031.     if (!osTypeInit) {
  1032.     osTypeInit = 1;
  1033.     Tcl_RegisterObjType(&osType);
  1034.     }
  1035.  
  1036.     objPtr = Tcl_NewObj();
  1037.     objPtr->bytes = NULL;
  1038.     objPtr->internalRep.longValue = newOSType;
  1039.     objPtr->typePtr = &osType;
  1040.     return objPtr;
  1041. }
  1042.  
  1043. /*
  1044.  *----------------------------------------------------------------------
  1045.  *
  1046.  * Tcl_SetOSTypeObj --
  1047.  *
  1048.  *    Modify an object to be a resource type and to have the 
  1049.  *    specified long value.
  1050.  *
  1051.  * Results:
  1052.  *    None.
  1053.  *
  1054.  * Side effects:
  1055.  *    The object's old string rep, if any, is freed. Also, any old
  1056.  *    internal rep is freed. 
  1057.  *
  1058.  *----------------------------------------------------------------------
  1059.  */
  1060.  
  1061. void
  1062. Tcl_SetOSTypeObj(
  1063.     Tcl_Obj *objPtr,        /* Object whose internal rep to init. */
  1064.     OSType newOSType)        /* Integer used to set object's value. */
  1065. {
  1066.     register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
  1067.  
  1068.     if (!osTypeInit) {
  1069.     osTypeInit = 1;
  1070.     Tcl_RegisterObjType(&osType);
  1071.     }
  1072.  
  1073.     Tcl_InvalidateStringRep(objPtr);
  1074.     if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
  1075.     oldTypePtr->freeIntRepProc(objPtr);
  1076.     }
  1077.     
  1078.     objPtr->internalRep.longValue = newOSType;
  1079.     objPtr->typePtr = &osType;
  1080. }
  1081.  
  1082. /*
  1083.  *----------------------------------------------------------------------
  1084.  *
  1085.  * Tcl_GetOSTypeFromObj --
  1086.  *
  1087.  *    Attempt to return an int from the Tcl object "objPtr". If the object
  1088.  *    is not already an int, an attempt will be made to convert it to one.
  1089.  *
  1090.  * Results:
  1091.  *    The return value is a standard Tcl object result. If an error occurs
  1092.  *    during conversion, an error message is left in interp->objResult
  1093.  *    unless "interp" is NULL.
  1094.  *
  1095.  * Side effects:
  1096.  *    If the object is not already an int, the conversion will free
  1097.  *    any old internal representation.
  1098.  *
  1099.  *----------------------------------------------------------------------
  1100.  */
  1101.  
  1102. int
  1103. Tcl_GetOSTypeFromObj(
  1104.     Tcl_Interp *interp,     /* Used for error reporting if not NULL. */
  1105.     Tcl_Obj *objPtr,        /* The object from which to get a int. */
  1106.     OSType *osTypePtr)        /* Place to store resulting int. */
  1107. {
  1108.     register int result;
  1109.     
  1110.     if (!osTypeInit) {
  1111.     osTypeInit = 1;
  1112.     Tcl_RegisterObjType(&osType);
  1113.     }
  1114.  
  1115.     if (objPtr->typePtr == &osType) {
  1116.     *osTypePtr = objPtr->internalRep.longValue;
  1117.     return TCL_OK;
  1118.     }
  1119.  
  1120.     result = SetOSTypeFromAny(interp, objPtr);
  1121.     if (result == TCL_OK) {
  1122.     *osTypePtr = objPtr->internalRep.longValue;
  1123.     }
  1124.     return result;
  1125. }
  1126.  
  1127. /*
  1128.  *----------------------------------------------------------------------
  1129.  *
  1130.  * DupOSTypeInternalRep --
  1131.  *
  1132.  *    Initialize the internal representation of an int Tcl_Obj to a
  1133.  *    copy of the internal representation of an existing int object. 
  1134.  *
  1135.  * Results:
  1136.  *    None.
  1137.  *
  1138.  * Side effects:
  1139.  *    "copyPtr"s internal rep is set to the integer corresponding to
  1140.  *    "srcPtr"s internal rep.
  1141.  *
  1142.  *----------------------------------------------------------------------
  1143.  */
  1144.  
  1145. static void
  1146. DupOSTypeInternalRep(
  1147.     Tcl_Obj *srcPtr,    /* Object with internal rep to copy. */
  1148.     Tcl_Obj *copyPtr)    /* Object with internal rep to set. */
  1149. {
  1150.     copyPtr->internalRep.longValue = srcPtr->internalRep.longValue;
  1151.     copyPtr->typePtr = &osType;
  1152. }
  1153.  
  1154. /*
  1155.  *----------------------------------------------------------------------
  1156.  *
  1157.  * SetOSTypeFromAny --
  1158.  *
  1159.  *    Attempt to generate an integer internal form for the Tcl object
  1160.  *    "objPtr".
  1161.  *
  1162.  * Results:
  1163.  *    The return value is a standard object Tcl result. If an error occurs
  1164.  *    during conversion, an error message is left in interp->objResult
  1165.  *    unless "interp" is NULL.
  1166.  *
  1167.  * Side effects:
  1168.  *    If no error occurs, an int is stored as "objPtr"s internal
  1169.  *    representation. 
  1170.  *
  1171.  *----------------------------------------------------------------------
  1172.  */
  1173.  
  1174. static int
  1175. SetOSTypeFromAny(
  1176.     Tcl_Interp *interp,        /* Used for error reporting if not NULL. */
  1177.     Tcl_Obj *objPtr)        /* The object to convert. */
  1178. {
  1179.     Tcl_ObjType *oldTypePtr = objPtr->typePtr;
  1180.     char *string;
  1181.     int length;
  1182.     long newOSType;
  1183.  
  1184.     /*
  1185.      * Get the string representation. Make it up-to-date if necessary.
  1186.      */
  1187.  
  1188.     string = TclGetStringFromObj(objPtr, &length);
  1189.  
  1190.     if (length != 4) {
  1191.     if (interp != NULL) {
  1192.         Tcl_ResetResult(interp);
  1193.         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  1194.             "expected Macintosh OS type but got \"", string, "\"",
  1195.             (char *) NULL);
  1196.     }
  1197.     return TCL_ERROR;
  1198.     }
  1199.     newOSType =  *((long *) string);
  1200.     
  1201.     /*
  1202.      * The conversion to resource type succeeded. Free the old internalRep 
  1203.      * before setting the new one.
  1204.      */
  1205.  
  1206.     if ((oldTypePtr != NULL) &&    (oldTypePtr->freeIntRepProc != NULL)) {
  1207.     oldTypePtr->freeIntRepProc(objPtr);
  1208.     }
  1209.     
  1210.     objPtr->internalRep.longValue = newOSType;
  1211.     objPtr->typePtr = &osType;
  1212.     return TCL_OK;
  1213. }
  1214.  
  1215. /*
  1216.  *----------------------------------------------------------------------
  1217.  *
  1218.  * UpdateStringOfOSType --
  1219.  *
  1220.  *    Update the string representation for an resource type object.
  1221.  *    Note: This procedure does not free an existing old string rep
  1222.  *    so storage will be lost if this has not already been done. 
  1223.  *
  1224.  * Results:
  1225.  *    None.
  1226.  *
  1227.  * Side effects:
  1228.  *    The object's string is set to a valid string that results from
  1229.  *    the int-to-string conversion.
  1230.  *
  1231.  *----------------------------------------------------------------------
  1232.  */
  1233.  
  1234. static void
  1235. UpdateStringOfOSType(
  1236.     register Tcl_Obj *objPtr)    /* Int object whose string rep to update. */
  1237. {
  1238.     objPtr->bytes = ckalloc(5);
  1239.     sprintf(objPtr->bytes, "%-4.4s", &(objPtr->internalRep.longValue));
  1240.     objPtr->length = 4;
  1241. }
  1242.